home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / 2.01 sources / Examples-2.01 / thermometer.lisp < prev    next >
Encoding:
Text File  |  1993-09-16  |  31.9 KB  |  780 lines  |  [TEXT/CCL2]
  1. ;-*- Mode: Lisp; Package: CCL -*-
  2.  
  3. ; thermometer.lisp
  4. ; A simple thermometer which displays one or more values in a rectangular area.
  5. ;
  6.  
  7. ;;;;;;;;;;;;;;;;;;;;;;
  8. ;;
  9. ;; Change History
  10. ;; 
  11. ;; 04/28/93 mwp Release
  12. ;; 02/09/93 bill (muldiv 1 255 1) now returns 255 instead of 256.
  13. ;; 03/26/92 wkf  Added handling of PixPats. 
  14. ;;               User must make (list PixPat) where a pattern would otherwise be passed.
  15. ;; ------------- 2.0
  16. ;; 02/23/92 gb   remove redundant EXPORTs.
  17. ;; 10/17/91 bill $ptask_draw-flag in %install-periodic-task
  18. ;; 09/30/91 bill Flavor's Technology's fix to muldiv
  19. ;; 08/12/91 bill add more ignored streams to FILE-THERMOMETER
  20. ;; 07/11/91 bill prevent rounding errors in view-draw-contents
  21. ;; 07/10/91 bill add static g/i space to GC-THERMOMETER.  Put mac heap on left (low addresses)
  22. ;; 07/09/91 bill add gc-theremometer, file-thermometer, some documentation
  23. ;;
  24.  
  25. ;;;;;;;;;;;;;;;;;;;;;;
  26. ;
  27. ; Documentation
  28. ;
  29. ; (make-instance 'thermometer . initargs)
  30. ; The initargs (in additions to those for a SIMPLE-VIEW) are:
  31. ;
  32. ; :pattern
  33. ;    Value is a Mac Pattern (or (list (list PixPat)) on color Macs) record
  34. ;    or a list of them using (list PixPat).  Defaults to *black-pattern*.
  35. ;    If there are more values than there are patterns, the
  36. ;    display code will cycle through the patterns until
  37. ;    it runs out of values.
  38. ;    The accessor for this slot is named THERMOMETER-PATTERN
  39. ; :fill-pattern
  40. ;    A Pattern (or (list PixPat)) to fill the empty space with.
  41. ;    Defaults to *white-pattern*
  42. ;    The accessor for this slot is named THERMOMETER-FILL-PATTERN
  43. ; :value-function
  44. ;    A function to call whenever the THERMOMETER-UPDATE-VALUES generic-function
  45. ;    is called on this THERMOMETER.  Should return a real number or a list of
  46. ;    real numbers.  The result becomes the THERMOMETER-VALUE.  The default
  47. ;    value is NIL which means the value is not changed by
  48. ;    THERMOMETER-UPDATE-VALUES.
  49. ;    The accessor for this slot is named THERMOMETER-VALUE-FUNCTION.
  50. ; :max-value-function
  51. ;    A function to call whenever THERMOMETER-UPDATE-VALUES is called. Should
  52. ;    return a positive real number which becomes the THERMOMETER-MAX-VALUE.
  53. ;    The default value is NIL, meaning no updating.
  54. ;    The accessor for this slot is named THERMOMETER-MAX-VALUE-FUNCTION
  55. ; :value
  56. ;    Initial state for the value(s) displayed by the thermometer.
  57. ;    Should be a real number or a list of real numbers.
  58. ;    The accessor for this slot is named THERMOMETER-VALUE
  59. ; :max-value
  60. ;    Initial state for the maximum-value displayed by the thermometer.
  61. ;    Should be a positive real number.
  62. ;    The THERMOMETER-VALUE should be less than this number (or the sum
  63. ;    of all the values in the list should be less than this number)
  64. ;    The accessor for this slot is named THERMOMETER-MAX-VALUE
  65. ; :direction
  66. ;    Which direction does the thermometer move.  Default is :VERTICAL.
  67. ;    The accessor for this slot is named THERMOMETER-DIRECTION.
  68. ;    The value of this slot should not be changed after the thermometer
  69. ;    has been created.
  70. ; :length
  71. ;    The length of the thermometer in the THERMOMETER-DIRECTION.
  72. ;    Used to set the VIEW-SIZE, when VIEW-SIZE is not explicitly specified
  73. ;    The accessor for this slot is named THERMOMETER-LENGTH.
  74. ; :width
  75. ;    The width of the thermometer in the THERMOMETER-DIRECTION.
  76. ;    Used to set the VIEW-SIZE, when VIEW-SIZE is not explicitly specified
  77. ;    The accessor for this slot is named THERMOMETER-WIDTH.
  78.  
  79. ; Methods other than the slot accessors:
  80. ;
  81. ; THERMOMETER-UPDATE-VALUES
  82. ;   Takes no arguments.  Calls the THERMOMETER-VALUE-FUNCTION, and
  83. ;   THERMOMETER-MAX-VALUE-FUNCTION and updates the THERMOMETER-VALUE and
  84. ;   THERMOMETER-MAX-VALUE slots with the results.  Invalidates the
  85. ;   THERMOMETER to force redrawing if any values change.
  86.  
  87. ; There is a simple commented-out example in the middle of this file,
  88. ; and two real-life examples at the bottom (the functions GC-THERMOMETER &
  89. ; FILE-THERMOMETER).
  90.  
  91. (in-package :ccl)
  92.  
  93. (eval-when (:compile-toplevel :load-toplevel :execute)
  94.   (export '(thermometer thermometer-pattern thermometer-fill-pattern
  95.             thermometer-value-function thermometer-max-value-function
  96.             thermometer-value thermometer-max-value
  97.             thermometer-direction thermometer-length thermometer-width
  98.             thermometer-update-values
  99.             thermo-window thermo-update-function 
  100.             add-thermo-update-function remove-thermo-update-function
  101.             gc-thermometer file-thermometer)))
  102.  
  103. (defclass thermometer (simple-view)
  104.   ((pattern :initarg :pattern 
  105.             :initform *black-pattern*
  106.             :accessor thermometer-pattern)
  107.    (fill-pattern :initarg :fill-pattern
  108.                  :initform *white-pattern*
  109.                  :accessor thermometer-fill-pattern)
  110.    (value-function :initarg :value-function :initform nil
  111.                    :accessor thermometer-value-function)
  112.    (max-value-function :initarg :max-value-function :initform nil
  113.                        :accessor thermometer-max-value-function)
  114.    (value :initarg :value :initform 0
  115.           :reader thermometer-value :writer (setf thermometer-value-slot))
  116.    (max-value :initarg :max-value :initform 100
  117.               :reader thermometer-max-value :writer (setf thermometer-max-value-slot))
  118.    (direction :initarg :direction :initform :vertical
  119.               :accessor thermometer-direction)
  120.    (length :initarg :length :initform 100
  121.            :reader thermometer-length :writer (setf thermometer-length-slot))
  122.    (width :initarg :width :initform 16
  123.           :reader thermometer-width :writer (setf thermometer-width-slot))))
  124.  
  125. (defmethod initialize-instance ((self thermometer) &rest rest &key 
  126.                                 view-size view-container)
  127.   (declare (dynamic-extent rest))
  128.   (apply #'call-next-method self :view-container nil rest)
  129.   (let ((direction (thermometer-direction self)))
  130.     (if view-size
  131.       (if (eq direction :vertical)
  132.         (setf (thermometer-width-slot self) (point-h view-size)
  133.               (thermometer-length-slot self) (point-v view-size))
  134.         (setf (thermometer-width-slot self) (point-v view-size)
  135.               (thermometer-length-slot self) (point-h view-size)))
  136.       (let ((length (thermometer-length self))
  137.             (width (thermometer-width self)))
  138.         (if (eq direction :vertical)
  139.           (set-view-size self width length)
  140.           (set-view-size self length width)))))
  141.   (if view-container
  142.     (set-view-container self view-container)))
  143.  
  144. (defmethod view-default-size ((self thermometer))
  145.   (if (eq (thermometer-direction self) :vertical)
  146.     (make-point (thermometer-width self) (thermometer-length self))
  147.     (make-point (thermometer-length self) (thermometer-width self))))
  148.  
  149. (defmethod (setf thermometer-width) (new-width (self thermometer))
  150.   (let ((length (thermometer-length self)))
  151.     (if (eq (thermometer-direction self) :vertical)
  152.       (set-view-size self new-width length)
  153.       (set-view-size self length new-width))))
  154.  
  155. (defmethod (setf thermometer-length) (new-length (self thermometer))
  156.   (let ((width (thermometer-width self)))
  157.     (if (eq (thermometer-direction self) :vertical)
  158.       (set-view-size self width new-length)
  159.       (set-view-size self new-length width))))
  160.  
  161. (defmethod set-view-size ((self thermometer) h &optional v)
  162.   (let ((size (make-point h v)))
  163.     (setq h (point-h size)
  164.           v (point-v size))
  165.     (if (eq (thermometer-direction self) :vertical)
  166.       (setf (thermometer-width-slot self) h
  167.             (thermometer-length-slot self) v)
  168.       (setf (thermometer-width-slot self) v
  169.             (thermometer-length-slot self) h))
  170.     (call-next-method)
  171.     (invalidate-view self)
  172.     size))
  173.  
  174. (defmethod (setf thermometer-value) (new-value (self thermometer))
  175.   (let ((old-value (thermometer-value self))
  176.         (update? nil))
  177.     (if (and (listp old-value) (listp new-value))
  178.       (if (eql (length old-value) (length new-value))
  179.         (let ((tail old-value))
  180.           (dolist (v new-value)
  181.             (unless (eql v (car tail))
  182.               (setf (car tail) v
  183.                     update? t))
  184.             (pop tail)))
  185.         (setf (thermometer-value self) (copy-list new-value)
  186.               update? t))
  187.       (when (setq update? (not (eql old-value new-value)))
  188.         (setf (thermometer-value-slot self) 
  189.               (if (listp new-value) (copy-list new-value) new-value))))
  190.     (when update?
  191.       (invalidate-view self)))
  192.   new-value)
  193.  
  194. (defmethod (setf thermometer-max-value) (new-max-value (self thermometer))
  195.   (unless (eql new-max-value (thermometer-max-value self))
  196.     (setf (thermometer-max-value-slot self)
  197.           (if (<= new-max-value 0) 1 new-max-value))
  198.     (invalidate-view self))
  199.   new-max-value)
  200.  
  201.  
  202. (eval-when (compile eval)
  203.   (require 'lapmacros))
  204.  
  205. (defun muldiv (m1 m2 d)
  206.   (or (and (fixnump m1) (fixnump m2) (fixnump d)
  207.            (>= (the fixnum m1) 0)
  208.            (>= (the fixnum m2) 0)
  209.            (> (the fixnum d) 0)
  210.            (lap-inline (m1 m2 d)
  211.              (getint arg_x)             ; m1
  212.              (getint arg_y)             ; m2
  213.              (getint arg_z)             ; d
  214.              (move.l arg_z db)          ; save for later
  215.              (mulu.l arg_x (arg_x arg_y))
  216.              (divu.l arg_z (arg_x arg_y))
  217.              (if# vs
  218.                (move.l nilreg acc)
  219.                else#
  220.                (move.l arg_y acc)
  221.                (asr.l db)
  222.                (if# (or (lt arg_x db)
  223.                         (and eq 
  224.                              (ne (tst.l arg_x))
  225.                              (ne (btst 0 acc))))
  226.                  (add.l ($ 1) acc))
  227.                (jsr_subprim $sp-mklong))))
  228.       (round (* m1 m2) d)))
  229.  
  230. (defmethod view-draw-contents ((self thermometer))
  231.   (let* ((pos (view-position self))
  232.          (size (view-size self))
  233.          (lr (add-points pos size))
  234.          (direction (thermometer-direction self)))
  235.     (with-pen-saved
  236.       (#_PenPat *black-pattern*)
  237.       (#_PenMode #$PatCopy)
  238.       (rlet ((rect :rect :topLeft pos :botRight lr))
  239.         (#_FrameRect rect)
  240.         (setq pos (add-points pos #@(1 1))
  241.               lr (subtract-points lr #@(1 1)))
  242.         (setf (rref rect :rect.topLeft) pos
  243.               (rref rect :rect.botRight) lr)
  244.         (let* ((values (list (thermometer-value self)))
  245.                (patterns (list (thermometer-pattern self)))
  246.                (max-value (thermometer-max-value self))
  247.                (length (thermometer-length self))
  248.                (vertical? (eq direction :vertical))
  249.                (left (point-h pos))
  250.                (right (point-h lr))
  251.                (top (point-v pos))
  252.                (bottom (point-v lr))
  253.                (start (if vertical? bottom left))
  254.                (total 0)
  255.                pattern patterns-list)
  256.           (declare (dynamic-extent values patterns))
  257.           (declare (list values patterns))
  258.           (declare (fixnum left right top bottom start length))
  259.           (if (listp (car values)) (setq values (car values)))
  260.           (if (listp (car patterns)) (setq patterns (car patterns)))
  261.           (setq patterns-list patterns)
  262.           (flet ((limit (value min max)
  263.                    (max min (min max value))))
  264.             (dolist (value values)
  265.               (setq pattern (pop patterns-list))
  266.               (if (null patterns-list) (setq patterns-list patterns))
  267.               (let* ((pixels (limit
  268.                               (muldiv (incf total value) length max-value)
  269.                               0 length))
  270.                      (split (if vertical?
  271.                               (- bottom pixels)
  272.                               (+ left pixels))))
  273.                 (declare (fixnum pixels split))
  274.                 (if vertical?
  275.                   (setf (rref rect :rect.topLeft)
  276.                         (make-point left
  277.                                     (limit split 
  278.                                            top
  279.                                            (limit (1- start) top bottom)))
  280.                         (rref rect :rect.botRight)
  281.                         (make-point right (limit start top bottom)))
  282.                   (setf (rref rect :rect.botRight)
  283.                         (make-point (limit split 
  284.                                            (limit (1+ start) left right)
  285.                                            right)
  286.                                     bottom)
  287.                         (rref rect :rect.topLeft)
  288.                         (make-point (limit start left right) top)))
  289.                 (if (listp pattern)
  290.                   (#_FillCRect rect (car pattern))
  291.                   (#_FillRect rect pattern))
  292.                 (setq start split))))
  293.           (if vertical?
  294.             (setf (rref rect :rect.topLeft) pos
  295.                   (rref rect :rect.botRight) (make-point right start))
  296.             (setf (rref rect :rect.topLeft) (make-point start top)
  297.                   (rref rect :rect.botRight) lr))
  298.           (let ((fill-pattern (thermometer-fill-pattern self)))
  299.             (if (consp fill-pattern)
  300.               (#_FillCRect rect (car fill-pattern))
  301.               (#_FillRect rect fill-pattern))))))))
  302.  
  303. (defmethod thermometer-update-values ((self thermometer))
  304.   (let* ((value-function (thermometer-value-function self))
  305.          (max-value-function (thermometer-max-value-function self))
  306.          (new-value (if value-function
  307.                       (funcall value-function)
  308.                       (thermometer-value self)))
  309.          (new-max-value (if max-value-function
  310.                           (funcall max-value-function) (thermometer-max-value self))))
  311.     (without-interrupts
  312.      (when value-function
  313.        (setf (thermometer-value self) new-value))
  314.      (when max-value-function
  315.        (setf (thermometer-max-value self) new-max-value)))
  316.     (values new-value new-max-value)))
  317.  
  318. #|
  319.  
  320. ; Example: two thermometers which track the mouse when you run (UPDATE-LOOP)
  321. ; and drag the mouse around in their window.
  322.  
  323. (defvar *thermometer-window* (make-instance 'window :view-size #@(200 146)))
  324. (defun example-patterns ()
  325.   (list *black-pattern* *gray-pattern*))
  326. (defvar *th* (make-instance 'thermometer
  327.                             :direction :horizontal
  328.                             :value (list 0 0)
  329.                             :pattern (example-patterns)
  330.                             :view-container *thermometer-window*
  331.                             :view-position #@(50 10)))
  332. (defvar *tv* (make-instance 'thermometer
  333.                             :direction :vertical
  334.                             :value (list 0 0)
  335.                             :pattern (example-patterns)
  336.                             :view-container *thermometer-window*
  337.                             :view-position #@(92 36)))
  338. ; *th* has two values, one which tracks the mouse in black
  339. ; and one which fills up half the remaining space in gray.
  340. (setf (thermometer-value-function *th*)
  341.       (let ((list (list 0 0))
  342.             (size (point-h (view-size *th*))))
  343.         #'(lambda ()
  344.             (let ((mouse (point-h (view-mouse-position *th*))))
  345.               (setf (car list) mouse
  346.                     (cadr list) (floor (- size mouse) 2)))
  347.             list)))
  348. ; *tv* has one value which tracks the mouse in black.
  349. (setf (thermometer-value-function *tv*)
  350.       (let ((size (point-v (view-size *tv*))))
  351.         #'(lambda ()
  352.             (- size (point-v (view-mouse-position *tv*))))))
  353.  
  354. (defun update-loop ()
  355.   (loop
  356.     (thermometer-update-values *th*)
  357.     (thermometer-update-values *tv*)
  358.     (event-dispatch)))
  359.  
  360. (update-loop)
  361.  
  362. |#
  363.  
  364. ;;;;;;;;;
  365. ;;
  366. ;; A windiod for displaying real-time thermometers
  367. ;;
  368. (defclass thermo-windoid (windoid)
  369.   ((update-function :initform nil
  370.                     :reader thermo-update-function))
  371.   (:default-initargs :window-type :single-edge-box))
  372.  
  373. (defmethod initialize-instance ((w thermo-windoid) &rest rest &key (window-show t)
  374.                                 color update-function)
  375.   (declare (dynamic-extent rest))
  376.   (apply #'call-next-method 
  377.          w :window-show nil :color-p color :windowdefproc nil rest)
  378.   (when color
  379.     (set-fore-color w color))
  380.   (when update-function
  381.     (setf (thermo-update-function w) update-function))
  382.   (when window-show
  383.     (window-show w)))
  384.  
  385. (defmethod (setf thermo-update-function) (value (w thermo-windoid) &aux f)
  386.   (cond ((typep value 'thermometer) 
  387.          (setq f #'(lambda () (thermometer-update-values value))))
  388.         ((listp value)
  389.          (dolist (th value) (require-type th 'thermometer))
  390.          (setq f #'(lambda ()
  391.                      (dolist (th value)
  392.                        (thermometer-update-values th)))))
  393.         ((or (functionp value) (symbolp value)) (setq f value))
  394.         (t (error "~s is not a thermometer, list of thermometers, function or symbol" value)))
  395.   (setf (slot-value w 'update-function) f)
  396.   (add-thermo-update-function f))
  397.  
  398. ; thermo-windoid's close when you double click them,
  399. ; Move when you drag them anywhere but the lower-right corner,
  400. ; And resize in the length direction when you drag them from
  401. ; the lower-right corner.
  402. (defmethod view-click-event-handler ((w thermo-windoid) where)
  403.   (if (double-click-p)
  404.     (window-close w)
  405.     (window-drag-event-handler w (add-points (view-position w) where))))
  406.  
  407. (defmethod window-close :after ((w thermo-windoid))
  408.   (remove-thermo-update-function (thermo-update-function w)))
  409.  
  410. (defvar *thermo-update-functions* nil)
  411.  
  412. (eval-when (:compile-toplevel :execute)
  413.   (require "LISPEQU"))                  ; for ccl::$ptask_draw-flag
  414.  
  415. ; (ccl::%install-periodic-task name function ticks &optional flags)
  416. ; $ptask_draw-flag means do not run this task if drawing is
  417. ; disabled (when a menu is down or the mouse is down in a control
  418. ; or during the repositioning or resizing of a window).
  419. (defun add-thermo-update-function (f)
  420.   (if (null *thermo-update-functions*)
  421.     (%install-periodic-task 'thermo-update 'thermo-update 60 $ptask_draw-flag))
  422.   (pushnew f *thermo-update-functions*))
  423.  
  424. ; (ccl::%remove-periodic-task name)
  425. (defun remove-thermo-update-function (f)
  426.   (unless (setq *thermo-update-functions*
  427.                 (delq f *thermo-update-functions*))
  428.     (%remove-periodic-task 'thermo-update)))
  429.  
  430. (defvar thermo-update nil)
  431.  
  432. (defun thermo-update ()
  433.   (let ((reentered? thermo-update)
  434.         (thermo-update t))
  435.     (unless reentered?
  436.       (dolist (f *thermo-update-functions*)
  437.         (funcall f)))))
  438.  
  439. ;;;;;;;;;
  440. ;;
  441. ;; A GC Thermometer
  442. ;;
  443.  
  444.  
  445. (defparameter *gc-sizes*
  446.   (list
  447.    0                                    ; heap size
  448.    0                                    ; mac heap used.
  449.    0                                    ; mac heap free
  450.    0                                    ; dynamic gspace
  451.    0                                    ; e2 gspace
  452.    0                                    ; e1 gspace
  453.    0                                    ; e0 gspace
  454.    0                                    ; free space
  455.    0                                    ; e0 ispace
  456.    0                                    ; e1 ispace
  457.    0                                    ; e2 ispace
  458.    0                                    ; dynamic ispace
  459.    0                                    ; static gspace
  460.    0                                    ; static ispace
  461.    ))
  462.  
  463. (defun gc-patterns ()
  464.   (list
  465.    *dark-gray-pattern*                  ; mac heap used.
  466.    *light-gray-pattern*                 ; mac heap free
  467.    *black-pattern*                      ; dynamic gspace
  468.    *dark-gray-pattern*                  ; e2 gspace
  469.    *gray-pattern*                       ; e1 gspace
  470.    *light-gray-pattern*                 ; e0 gspace
  471.    *white-pattern*                      ; free space
  472.    *light-gray-pattern*                 ; e0 ispace
  473.    *gray-pattern*                       ; e1 ispace
  474.    *dark-gray-pattern*                  ; e2 ispace
  475.    *black-pattern*                      ; dynamic ispace
  476.    *light-gray-pattern*                 ; static gspace
  477.    *dark-gray-pattern*                  ; static ispace
  478.    ))
  479.  
  480. (defun heap-size ()
  481.   (let* ((start (%get-long (%int-to-ptr #$applzone)))
  482.          (end (%get-long (%int-to-ptr start))))
  483.     (- end start)))
  484.  
  485. (defun gc-sizes ()
  486.   (without-interrupts
  487.    (let* ((heap-size (heap-size))
  488.           (free-bytes (%freebytes))
  489.           (mac-free (#_FreeMem))
  490.           mac-used
  491.           dg di e0g e0i e1g e1i e2g e2i sg si)
  492.      (multiple-value-setq (dg di) (cons-area-sizes :dynamic))
  493.      (multiple-value-setq (e0g e0i) (cons-area-sizes 0))
  494.      (multiple-value-setq (e1g e1i) (cons-area-sizes 1))
  495.      (multiple-value-setq (e2g e2i) (cons-area-sizes 2))
  496.      (multiple-value-setq (sg si) (cons-area-sizes :static))
  497.      (setq mac-used  (- heap-size mac-free (%dynamic-heap-size) sg si))
  498.      (let ((sizes *gc-sizes*)
  499.            (i -1))
  500.        (declare (fixnum i))
  501.        (setf
  502.         (nth (incf i) sizes) heap-size
  503.         (nth (incf i) sizes) mac-used
  504.         (nth (incf i) sizes) mac-free
  505.         (nth (incf i) sizes) dg
  506.         (nth (incf i) sizes) e2g
  507.         (nth (incf i) sizes) e1g
  508.         (nth (incf i) sizes) e0g
  509.         (nth (incf i) sizes) free-bytes
  510.         (nth (incf i) sizes) e0i
  511.         (nth (incf i) sizes) e1i
  512.         (nth (incf i) sizes) e2i
  513.         (nth (incf i) sizes) di
  514.         (nth (incf i) sizes) sg
  515.         (nth (incf i) sizes) si
  516.         )
  517.        (cdr sizes)))))
  518.  
  519. (defun gc-total-size () 
  520.   (car *gc-sizes*))  
  521.  
  522. (defparameter *egc-sizes*
  523.   (list 0                               ; total size
  524.         0                               ; e2 gspace
  525.         0                               ; e1 gspace
  526.         0                               ; e0 gspace
  527.         0                               ; free space in e0
  528.         0                               ; e0 ispace
  529.         0                               ; e1 ispace
  530.         0                               ; e2 ispace
  531.         ))
  532.  
  533. (defun egc-patterns ()
  534.   (list *dark-gray-pattern*             ; e2 gspace
  535.         *gray-pattern*                  ; e1 gspace
  536.         *light-gray-pattern*            ; e0 gspace
  537.         *white-pattern*                 ; free space in e0
  538.         *light-gray-pattern*            ; e0 ispace
  539.         *gray-pattern*                  ; e1 ispace
  540.         *dark-gray-pattern*             ; e2 ispace
  541.         ))
  542.  
  543. (defun egc-sizes ()
  544.   (let* (e0g e0i e0-total e1g e1i e2g e2i)
  545.     (multiple-value-setq (e0g e0i e0-total) (cons-area-sizes 0))
  546.     (multiple-value-setq (e1g e1i) (cons-area-sizes 1))
  547.     (multiple-value-setq (e2g e2i) (cons-area-sizes 2))
  548.     (let* ((sizes *egc-sizes*)
  549.            (total-size (+ e0g e0i e1g e1i e2g e2i))
  550.            (empty-space (max 0 (- e0-total e0g e0i))))
  551.       (setf (nth 0 sizes) (+ total-size empty-space)
  552.             (nth 1 sizes) e2g
  553.             (nth 2 sizes) e1g
  554.             (nth 3 sizes) e0g
  555.             (nth 4 sizes) empty-space
  556.             (nth 5 sizes) e0i
  557.             (nth 6 sizes) e1i
  558.             (nth 7 sizes) e2i)
  559.       (cdr sizes))))
  560.  
  561. (defun egc-total-size ()
  562.   (car *egc-sizes*))
  563.  
  564. (defclass gc-windoid (thermo-windoid) ())
  565.  
  566. (defmethod view-click-event-handler ((w gc-windoid) where)
  567.   (if (double-click-p)
  568.     (window-close w)
  569.     (let* ((size (view-size w))
  570.            (global-where (add-points where (view-position w))))
  571.       (if (and (> (point-h where) (- (point-h size) 5))
  572.                (> (point-v where) (- (point-v size) 5)))
  573.         (let* ((th (car (subviews w)))
  574.                (direction (thermometer-direction th))
  575.                (vertical? (eq direction :vertical))
  576.                (size-h (point-h size))
  577.                (size-v (point-v size))
  578.                (topleft (if vertical?
  579.                           (make-point (1+ size-h) 100)
  580.                           (make-point 100 (1+ size-v))))
  581.                (botright (if vertical?
  582.                            (make-point (1+ size-h) 8192)
  583.                            (make-point 8192 (1+ size-v)))))
  584.           (rlet ((rect :rect :topleft topleft :botright botright))
  585.             (unless (eql 0 (setq size (#_GrowWindow (wptr w) global-where rect)))
  586.               (set-view-size w (if vertical?
  587.                                  (make-point size-h (point-v size))
  588.                                  (make-point (point-h size) size-v))))))
  589.         (window-drag-event-handler w global-where)))))
  590.  
  591. (defmethod set-view-size :after ((w gc-windoid) h &optional v)
  592.   (declare (ignore h v))
  593.   (let* ((subviews (subviews w))
  594.          (direction (thermometer-direction (car subviews)))
  595.          (size (view-size w)))
  596.     (unless (null (cdr subviews))
  597.       (let ((h (point-h size))
  598.             (v (point-v size)))
  599.         (setq size (if (eq direction :vertical)
  600.                      (make-point (floor h 2) v)
  601.                      (make-point h (floor v 2))))))
  602.     (dolist (th subviews)
  603.       (set-view-size th
  604.                  (add-points size #@(2 2))))))
  605.  
  606. ; Heres the function to call to make a GC Thermometer.
  607. ; The defaults put the thermometer at the bottom of the highest resolution
  608. ; color screen, and include an EGC thermometer if EGC is turned on.
  609. ; By default all other gc-windoid's are closed before the new one is created.
  610. (defun gc-thermometer (&key length (width 10) position
  611.                             (color *blue-color*) (direction :horizontal)
  612.                             (egc-p (egc-enabled-p))
  613.                             (close-p t)
  614.                             &aux
  615.                             (vertical? (eq direction :vertical))
  616.                             (window-width (if egc-p (+ width width 1) width)))
  617.   (when close-p
  618.     (dolist (w (windows :class 'gc-windoid :include-invisibles t))
  619.       (window-close w)))
  620.   (let ((screen-width *screen-width*)
  621.         (screen-height *screen-height*)
  622.         (screen-left 0)
  623.         (screen-top 0))
  624.     (multiple-value-bind (screen-pos screen-size) 
  625.                          (if position (find-screen position) (find-best-color-screen))
  626.       (when screen-pos
  627.         (setq screen-left (point-h screen-pos)
  628.               screen-top (point-v screen-pos)
  629.               screen-width (point-h screen-size)
  630.               screen-height (point-v screen-size))))
  631.     (unless position
  632.       (setq position
  633.             (if vertical?
  634.               (make-point (- (+ screen-left screen-width) window-width) screen-top)
  635.               (make-point screen-left (- (+ screen-top screen-height) window-width)))))
  636.     (unless length
  637.       (setq length (if vertical?
  638.                      (- screen-height (- (point-v position) screen-top))
  639.                      (- screen-width (- (point-h position) screen-left)))))
  640.     (when (floatp length)
  641.       (setq length (if vertical?
  642.                      (floor (* screen-height length))
  643.                      (floor (* screen-width length))))))
  644.   (let* ((th (make-instance 'thermometer
  645.                             :view-position #@(-1 -1)
  646.                             :length (+ length 2)
  647.                             :width (+ width 2)
  648.                             :direction direction
  649.                             :pattern (gc-patterns)
  650.                             :value-function 'gc-sizes
  651.                             :max-value-function 'gc-total-size))
  652.          (eth (and egc-p
  653.                    (make-instance 'thermometer
  654.                                   :view-position (if vertical?
  655.                                                    (make-point width -1)
  656.                                                    (make-point -1 width))
  657.                                   :length (+ length 2)
  658.                                   :width (+ width 2)
  659.                                   :direction direction
  660.                                   :pattern (egc-patterns)
  661.                                   :value-function 'egc-sizes
  662.                                   :max-value-function 'egc-total-size)))
  663.          (w (make-instance 'gc-windoid
  664.                            :view-size (if vertical?
  665.                                         (make-point window-width length)
  666.                                         (make-point length window-width))
  667.                            :view-position position
  668.                            :update-function (if eth (list th eth) th)
  669.                            :color color)))
  670.     (set-view-container th w)
  671.     (thermometer-update-values th)
  672.     (when eth
  673.       (set-view-container eth w)
  674.       (thermometer-update-values eth))
  675.     w))
  676.   
  677. ;;;;;;;;;
  678. ;;
  679. ;; A thermometer to track the currently open file.
  680. ;; Lets you see progress of file compilation.
  681. ;;
  682.  
  683.  
  684. ; Test me.
  685. (defclass file-thermo-windoid (thermo-windoid)
  686.   ((stream-pos-size :initform nil 
  687.                     :initarg :stream-pos-size
  688.                     :accessor stream-pos-size)))
  689.  
  690. ; This should take a font parameter and query the font about its
  691. ; size rather than hard-coding the size of monaco 9.
  692. ; By default the windoid is put at the top-left corner of the main
  693. ; screen.  It pops up automatically when there is a file open to display,
  694. ; and disappears again when there isn't.
  695. ; All other file-thermo-windoid's are closed before the new one is created,
  696. ; unless CLOSE-P is specified as NIL.
  697. (defun file-thermometer (&key (length 250) (close-p t))
  698.   (when close-p
  699.     (dolist (w (windows :class 'file-thermo-windoid :include-invisibles t))
  700.       (window-close w)))
  701.   (let* ((th (make-instance 'thermometer
  702.                             :direction :horizontal
  703.                             :length (+ length 2)
  704.                             :view-position #@(-1 -1)
  705.                             :width 10))
  706.          (stream nil)
  707.          (pos nil)
  708.          (size nil)
  709.          w)
  710.     (flet ((update-function ()
  711.              (when (and w (wptr w))
  712.                (let ((new-stream nil)
  713.                      new-size new-pos)
  714.                  (dolist (stream *open-file-streams*)
  715.                    (unless (or (member stream
  716.                                        '(*doc-string-stream* *traps-index-stream*
  717.                                          *constants-index-stream* *records-index-stream*
  718.                                          *mactypes-index-stream*)
  719.                                        :key #'symbol-value)
  720.                                (not (open-stream-p stream)))
  721.                      (return (setq new-stream stream))))
  722.                  (when new-stream
  723.                    (unless (ignore-errors
  724.                             (and (setq new-size (file-length new-stream))
  725.                                  (setq new-pos (file-position new-stream))))
  726.                      (setq new-stream nil)))
  727.                  (if new-stream
  728.                    (unless (and (eq new-stream stream)
  729.                                 (eql new-pos pos)
  730.                                 (eql new-size size))
  731.                      (setq stream new-stream
  732.                            pos new-pos
  733.                            size new-size)
  734.                      (setf (thermometer-max-value th) (max size 1)
  735.                            (thermometer-value th) pos)
  736.                      (invalidate-view w)
  737.                      (window-show w))
  738.                    ; There's a little delay in closing the window in case
  739.                    ; we sample a stream while it's being closed.
  740.                    (progn
  741.                      (when stream
  742.                        (window-hide w)
  743.                        (setq stream nil)
  744.                        (setf (thermometer-value th) 0)))))))
  745.            (stream-pos-size () (values stream pos size)))
  746.       (setq w (make-instance 'file-thermo-windoid
  747.                              :view-font '("Monaco" 9 :srccopy)
  748.                              :update-function #'update-function
  749.                              :stream-pos-size #'stream-pos-size
  750.                              :window-show nil
  751.                              :view-size (make-point length 24)
  752.                              :view-subviews (list th #|text|#)
  753.                              :view-position (make-point
  754.                                              0
  755.                                              (%get-word
  756.                                               (%int-to-ptr
  757.                                                #$MBarHeight))))))))
  758.  
  759. (defmethod view-draw-contents ((w file-thermo-windoid))
  760.   (call-next-method)
  761.   (multiple-value-bind (stream pos size) (funcall (stream-pos-size w))
  762.     (#_MoveTo 5 20)
  763.     (if (and stream pos size)
  764.       (let ((name (stream-filename stream)))
  765.         (format w "~a~@[.~a~]  ~d/~d  ~d%"
  766.                 (pathname-name name)
  767.                 (let ((type (pathname-type name)))
  768.                   (and (neq type :unspecific) type))
  769.                 pos size (if (zerop size)
  770.                            0
  771.                            (round (* 100 pos) size)))))
  772.     (rlet ((pt :point))
  773.       (#_GetPen pt)
  774.       (rlet ((rect :rect
  775.                    :top 11 :left (point-h (%get-long pt))
  776.                    :botright (view-size w)))
  777.         (#_EraseRect rect)))))
  778.   
  779. (provide 'thermometer)
  780.